home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Magnum One
/
Magnum One (Mid-American Digital) (Disc Manufacturing).iso
/
d18
/
gsdb21.arc
/
GS_DBFLD.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-01-04
|
47KB
|
1,403 lines
{ dBase III Field Handler
GS_DBFLD Copyright (c) Richard F. Griffin
15 November 1990
102 Molded Stone Pl
Warner Robins, GA 31088
-------------------------------------------------------------
This unit handles field processing for all dBase III file (.DBF)
operations.
SHAREWARE -- COMMERCIAL USE RESTRICTED
Changes:
}
{
┌──────────────────────┐
│ INTERFACE SECTION: │
└──────────────────────┘
}
unit GS_dBFld;
interface
uses
CRT,
GS_Edit,
GS_FileH,
GS_Error,
GS_KeyI,
GS_Strng,
GS_Wind,
GS_dBase;
type
GS_dBFld_Objt = object(GS_dBase_dB)
LastFldTyp : char; {Last FieldGet type field}
LastFldDec : integer; {Last FieldGet Decimals}
LastFldLth : integer; {Last FieldGet Length}
LastFldNam : string[11]; {Last FieldGet Name}
LastFldNum : integer; {Last FieldGet Number}
EditOn : boolean; {Edit allowed}
RecChanged : boolean; {Flag for record changed}
Memo_Loc : longint; {Starting memo block for field}
Memo_Bloks : integer; {Number of blocks used for the field}
Memo_Store : GS_Edit_Objt; {Object to store/edit memos}
DeleteOnF9 : boolean; {Flag to permit F9 to delete/undelete}
Procedure Check_Func_Keys; virtual;
Function Create(FName : string) : boolean;
function DateGet(st : string) : string;
function DateGetN(n : integer) : string;
Procedure DatePut(st, data : string);
Procedure DatePutN(n : integer; data : string);
Function FieldAccept(st,Titl : string; x,y : integer) : string;
Procedure FieldDisplay(st,Titl : string; x,y : integer);
Function FieldDisplayScreen : boolean;
Function FieldGet(st : string) : string;
Function FieldGetN(n : integer) : string;
Procedure FieldPut(st1, st2 : string);
Procedure FieldPutN(n : integer; st1 : string);
Function FieldUpdateScreen : boolean;
Function FieldAppendScreen(empty : boolean) : boolean;
Function Formula(st : string) : string; virtual;
Function HuntFieldName(st : string; var fs : integer) : boolean;
Procedure IndexTo(filname, formla : string);
Constructor Init(FName : string);
function LogicGet(st : string) : boolean;
function LogicGetN(n : integer) : boolean;
Procedure LogicPut(st : string; b : boolean);
Procedure LogicPutN(n : integer; b : boolean);
Procedure MemoEdit;
function MemoGetLine(linenum : integer) : string;
procedure MemoGet(rpt : string);
Procedure MemoWidth(l : integer);
function MemoLines : integer;
function MemoPut : string;
function NumberGet(st : string) : real;
function NumberGetN(n : integer) : real;
Procedure NumberPut(st : string; r : real);
Procedure NumberPutN(n : integer; r : real);
Procedure Pack;
function StringGet(st : string) : string;
function StringGetN(n : integer) : string;
Procedure StringPut(st1, st2 : string);
Procedure StringPutN(n : integer; st1 : string);
end;
implementation
procedure GS_dBFld_Objt.Check_Func_Keys;
begin
case ch of
Kbd_F9 : begin
if DeleteOnF9 then
begin
if RecNumber < 0 then
begin
if DelFlag then CurRecord^[0] := 32
else CurRecord^[0] := 42;
DelFlag := not DelFlag;
end
else if DelFlag then UnDelete else Delete;
GS_KeyI_Ret := true;
Ch := Kbd_Ret;
end else GS_dBase_DB.Check_Func_Keys;
end;
Kbd_F10 : begin
GS_KeyI_Ret := true;
Ch := Kbd_Ret;
end;
else GS_dBase_DB.Check_Func_Keys;
end;
end;
function GS_dBFld_Objt.DateGet(st : string) : string;
var
t : string;
begin
t := FieldGet(st);
DateGet := StrDate(t);
end;
function GS_dBFld_Objt.DateGetN(n : integer) : string;
var
data,
t : string;
begin
t := FieldGetN(n);
DateGetN := StrDate(t);
end;
Procedure GS_dBFld_Objt.DatePut(st, data : string);
var
f : integer;
valu : string[2];
t : string;
begin
if not HuntFieldName(st,f) then
begin
ShowError(625,st);
exit;
end;
move(data[1], t[5], 2);
move(data[4], t[7], 2);
move(data[7], t[3], 2);
valu := '19'; {Use 19 for first two digits - this will}
{have to be changed in the year 2000}
move(valu[1], t[1], 2); {Move the first two year digits to record}
t[0] := #8;
FieldPutN(f,t);
end;
Procedure GS_dBFld_Objt.DatePutN(n : integer; data : string);
var
valu : string[2];
t : string;
begin
if n > NumFields then
begin
ShowError(627,'Field number out of range');
exit;
end;
move(data[1], t[5], 2);
move(data[4], t[7], 2);
move(data[7], t[3], 2);
valu := '19'; {Use 19 for first two digits - this will}
{have to be changed in the year 2000}
move(valu[1], t[1], 2); {Move the first two year digits to record}
t[0] := #8;
FieldPutN(n,t);
end;
function GS_dBFld_Objt.LogicGet(st : string) : boolean;
begin
LogicGet := ValLogic(FieldGet(st));
end;
function GS_dBFld_Objt.LogicGetN(n : integer) : boolean;
begin
LogicGetN := ValLogic(FieldGetN(n));
end;
Procedure GS_dBFld_Objt.LogicPut(st : string; b : boolean);
begin
FieldPut(st,StrLogic(b));
end;
Procedure GS_dBFld_Objt.LogicPutN(n : integer; b : boolean);
begin
FieldPutN(n,StrLogic(b));
end;
function GS_dBFld_Objt.NumberGet(st : string) : real;
var
r : integer;
v : real;
s : string;
begin
s := TrimR(FieldGet(st));
r := 0;
if s = '' then v := 0 else val(s,v,r);
if r <> 0 then
begin
ShowError(620,'Not a valid numeric field in NumberGet'+s);
v := 0;
end;
NumberGet := v;
end;
function GS_dBFld_Objt.NumberGetN(n : integer) : real;
var
r : integer;
v : real;
s : string;
begin
s := TrimR(FieldGetN(n));
r := 0;
if s = '' then v := 0 else val(s,v,r);
if r <> 0 then
begin
ShowError(620,'Not a valid numeric field in NumberGetN - '+s);
v := 0;
end;
NumberGetN := v;
end;
Procedure GS_dBFld_Objt.NumberPut(st : string; r : real);
var
f : integer;
s : string;
begin
if not HuntFieldName(st,f) then
begin
ShowError(625,st);
exit;
end;
Str(r:LastFldLth:LastFldDec,s);
FieldPutN(f,s);
end;
Procedure GS_dBFld_Objt.NumberPutN(n : integer; r : real);
var
s : string;
begin
if n > NumFields then
begin
ShowError(627,'Field number out of range');
exit;
end;
Str(r:Fields^[n].FieldLen:Fields^[n].FieldDec,s);
FieldPutN(n,s);
end;
function GS_dBFld_Objt.StringGet(st : string) : string;
begin
StringGet := TrimR(FieldGet(st));
end;
function GS_dBFld_Objt.StringGetN(n : integer) : string;
begin
StringGetN := TrimR(FieldGetN(n));
end;
Procedure GS_dBFld_Objt.StringPut(st1,st2 : string);
begin
FieldPut(st1,st2);
end;
Procedure GS_dBFld_Objt.StringPutN(n : integer; st1 : string);
begin
FieldPutN(n,st1);
end;
function GS_dBFld_Objt.HuntFieldName(st : string; var fs : integer) : boolean;
var
FSt : string;
mtch : boolean;
begin
FSt := AllCaps(st); {Capitalize the workstring}
FSt := TrimR(FSt); {Remove trailing spaces}
fs := 1; {Initialize field count}
mtch := false; {Set match found to false}
while (not mtch) and (fs <= NumFields) DO
if FieldsN^[fs] = FSt then mtch := true else inc(fs);
if mtch then
begin
LastFldTyp := Fields^[fs].FieldType;
LastFldDec := Fields^[fs].FieldDec;
LastFldLth := Fields^[fs].FieldLen;
end;
HuntFieldName := mtch;
end;
Function GS_dBFld_Objt.Create(FName : string) : boolean;
begin
if GS_dBase_DB.Create(FName) then
begin
Init(FName);
Create := true;
end else Create := false;
end;
Procedure GS_dBFld_Objt.Pack;
const
EOFMark : Byte = $1A;
var
df : file; {Local file variable for memo work file}
mbuf : array[0..GS_dBase_MaxMemoRec] of byte;
rsl : word;
i, j : longint; {Local variables }
mcnt,
tcnt : longint;
done : boolean;
rl : real;
FNam : string[64];
procedure UpdateMemo;
var
fp : integer;
begin
for fp := 1 to NumFields do
begin
if Fields^[fp].FieldType = 'M' then
begin
Memo_Loc := Trunc(NumberGetN(fp));
Memo_Bloks := 0; {Initialize blocks read}
if (Memo_Loc <> 0) then
begin
tcnt := GS_FileSize(df);
rl := tcnt;
NumberPutN(fp,rl);
done := false; {Reset done flag to false}
while (not done) do {loop until done (EOF mark)}
begin
GS_FileRead(mFile, Memo_Loc+Memo_Bloks, mbuf, 1, rsl);
inc(Memo_Bloks);
mCnt := 0; {Counter into disk read buffer}
while (mCnt < GS_dBase_MaxMemoRec) and (done = false) do
begin
if mbuf[mcnt] = $1A then done := true;
inc (mcnt);
end;
if not done then GS_FileWrite(df,-1,mbuf,1, rsl);
end;
FillChar(mbuf[mcnt],GS_dBase_MaxMemoRec - mcnt,#0);
GS_FileWrite(df,-1,mbuf,1, rsl);
{Write the last block to the .DBT}
end;
end;
end;
end;
begin {Pack}
i := 1;
while dbfNdxTbl[i] <> nil do
begin
dbfNdxTbl[i]^.Ndx_Close;
Dispose(dbfNdxTbl[i]);
dbfNdxTbl[i] := nil;
inc(i);
end;
dbfNdxActv := false; {Set index active flag to false}
j := 0;
if WithMemo then
begin
GS_FileAssign(df,'DB3$$$.D$$',2048);
GS_FileRewrite(df,GS_dBase_MaxMemoRec);
FillChar(mbuf,GS_dBase_MaxMemoRec,#0);
mbuf[0] := 1;
GS_FileWrite(df,0,mbuf,1,rsl);
end;
for i := 1 to NumRecs do {Read .DBF sequentially}
begin
GetRec(i);
if not DelFlag then {Write to work file if not deleted}
begin
inc(j); {Increment record count for packed file }
if WithMemo then UpdateMemo;
PutRec(j);
end;
end;
if i > j then {If records were deleted then...}
begin
NumRecs := j; {Store new record count in objectname}
GS_FileWrite(dfile, HeadLen+(j*RecLen)+1, EOFMark, 1, rsl);
{Write End of File byte at file end}
GS_FileTruncate(dfile,HeadLen+(j*RecLen)+1);
{Set new file size for dBase file};
end;
if WithMemo then
begin
tcnt := GS_FileSize(df);
FillChar(mbuf,GS_dBase_MaxMemoRec,#0);
Move(tcnt,mbuf[0],4);
GS_FileWrite(df,0,mbuf,1, rsl);
{Write the block to the .DBT. It will}
{point to the next available block};
FNam := FileName;
FNam[length(FNam)] := 'T';
GS_FileClose(mFile);
GS_FileClose(df);
GS_FileErase(mFile); {Erase original file}
GS_FileRename(df, FNam); {Rename work file to original file name}
GS_FileAssign(mFile, FNam, 2048); {Set file type to new file}
GS_FileReset(mFile, GS_dBase_MaxMemoRec);
end;
END; { Pack }
Function GS_dBFld_Objt.FieldAccept(st,Titl : string; x,y : integer) : string;
var
txtatrb,
i,
v : integer; {Counter variables}
t : string[255]; {Work string to hold default (old) value}
f : string[2];
Procedure AcceptC;
var
r_c : string;
begin
GS_Wind_SetIVMode;
if EditOn then {If edit permitted, then go edit string}
begin
r_c := t;
t := EditString(t, v, y, LastFldLth);
if t <> r_c then RecChanged := true;
end
else
begin
gotoxy(v,y); {Go to start of field screen position}
write(t,'':LastFldLth-length(t));
{Rewrite the string on screen inverted}
WaitForKey;
end;
GS_Wind_SetNmMode;
gotoxy(v,y); {Go to start of field screen position}
write(t,'':LastFldLth-length(t));
{Rewrite the string on screen in the original color}
end;
Procedure AcceptD;
var
data : string[10];
valu,
yy,
mm,
dd : string[2];
mmn,
ddn,
yyn,
rsl : integer;
cc : char;
okDate : boolean;
begin
t := StrDate(t);
okDate := false;
repeat
AcceptC;
if not EditOn then exit;
if TrimR(t) = ' / /' then exit;
data := t;
cc := t[3];
if cc in ['0'..'9'] then
begin
mm := copy(data,5,2);
dd := copy(data,7,2);
yy := copy(data,3,2);
end
else
begin
mm := copy(data,1,2);
dd := copy(data,4,2);
yy := copy(data,7,2);
end;
val(mm,mmn,rsl);
if rsl = 0 then
begin
val(dd,ddn,rsl);
if rsl = 0 then
begin
val(yy,yyn,rsl);
if rsl = 0 then
begin
if mmn in [1..12] then
if ddn in [1..31] then
okDate := true;
end;
end;
end;
if not okDate then SoundBell(BeepTime,BeepFreq);
until okDate;
if cc in ['0'..'9'] then begin end
else
begin
move(data[1], t[5], 2);
move(data[4], t[7], 2);
move(data[7], t[3], 2);
valu := '19'; {Use 19 for first two digits - this will}
{have to be changed in the year 2000}
move(valu[1], t[1], 2); {Move the first two year digits to record}
t[0] := #8;
end;
end;
Procedure AcceptL;
var
data : string[1];
begin
{
┌─────────────────────────────────────┐
│ Accept keyboard entry. Loop until │
│ value is T,t,Y,y,F,f,N,n. │
└─────────────────────────────────────┘
}
repeat
if t = '' then t := 'F';
AcceptC;
if not EditOn then exit;
if t[1] in ['T','t','Y','y','F','f','N','n'] then
begin end else SoundBell(BeepTime,BeepFreq);
until t[1] in ['T','t','Y','y','F','f','N','n'];
if t[1] in ['T','t','Y','y'] then t[1] := 'T' else t[1] := 'F';
end;
procedure AcceptM;
var
ans : string[10]; {Work string to hold edit value}
r_c : string[10]; {Work string for memo block number}
begin
GS_Wind_SetIvMode;
ans := 'N'; {Initialize ans to false}
if EditOn then write(' Edit ? ') else write(' View ? ');
repeat
ans := EditString(ans,v+9,y,1);
{Go edit string t for 1 character}
{at cursor position v,y}
if ans[1] in ['T','t','Y','y','F','f','N','n'] then
begin end else SoundBell(BeepTime,BeepFreq);
until ans[1] in ['T','t','Y','y','F','f','N','n'];
GS_Wind_SetNmMode; {Restore original text attribute}
gotoxy(v,y); {Now reset to 'memo' for field name}
write('---memo---');
if ans[1] in ['T','t','Y','y'] then
begin
r_c := t;
MemoGet(t);
If EditOn then Memo_Store.Edit else Memo_Store.View;
if (EditOn) and (GS_KeyI_Esc) then
begin
GS_KeyI_Esc := false; {Reset Escape flag so its not used}
{elsewhere}
GS_KeyI_Chr := ' ';
MemoGet(t);
end
else
begin
GS_KeyI_Chr := ' '; {Clear character last entered}
if EditOn then t := MemoPut;
if t <> r_c then RecChanged := true;
end;
end;
end;
Procedure AcceptN;
var
data : string;
i : integer;
r : real;
begin
{
┌─────────────────────────────────────┐
│ Accept keyboard entry. Loop until │
│ value is Numeric. │
└─────────────────────────────────────┘
}
repeat
if t = '' then Str(0.0:LastFldLth:LastFldDec,t);
AcceptC;
if not EditOn then exit;
val(t, r, i);
if i = 0 then
begin
Str(r:LastFldLth:LastFldDec,t);
if length(t) > LastFldLth then i := 999;
end;
if i <> 0 then
begin
SoundBell(BeepTime,BeepFreq);
t := '';
end;
until i = 0; {i will be 0 when data is a valid number}
gotoxy(v,y); {Go to start of field screen position}
write(t,'':LastFldLth-length(t));
{Rewrite the string on screen in the original color}
end;
begin
GotoXY(x,y); {Go to position on screen}
write(Titl); {Write the title of field}
v := WhereX; {Save the position after writing title}
t := TrimR(FieldGet(st)); {Get the field in the work string}
case LastFldTyp of
'C' : begin
AcceptC;
FieldAccept := t; {Return the string to calling routine}
end;
'D' : begin
AcceptD;
FieldAccept := t;
end;
'L' : begin
AcceptL;
FieldAccept := t;
end;
'M' : begin
AcceptM;
FieldAccept := t;
end;
'N' : begin
AcceptN;
FieldAccept := t;
end;
end;
end;
Procedure GS_dBFld_Objt.FieldDisplay(st,Titl : string; x,y : integer);
var
i,
v : integer; {Counter variables}
t : string[255]; {Work string to hold default (old) value}
data : string[10];
begin
GotoXY(x,y); {Go to position on screen}
write(Titl); {Write the title of field}
v := WhereX; {Save the position after writing title}
t := TrimR(FieldGet(st)); {Get the field in the work string}
case LastFldTyp of
'C',
'L' : begin
gotoxy(v,y); {Go to start of field screen position}
write(t,'':LastFldLth-length(t));
{Write the string on screen }
end;
'D' : begin
t := StrDate(t);
write(t);
end;
'N' : begin
if t = '' then t := '0';
gotoxy(v,y); {Go to start of field screen position}
write(t:LastFldLth);
end;
'M' : begin
gotoxy(v,y); {Go to start of field screen position}
write('---memo---'); {Write the '---memo--- on screen }
end;
end;
end;
Function GS_dBFld_Objt.FieldDisplayScreen : boolean;
var
f,
h : boolean;
begin
h := EditOn;
EditOn := false;
f := FieldUpdateScreen;
EditOn := h;
FieldDisplayScreen := f;
end;
function GS_dBFld_Objt.FieldGetN(n : integer) : String;
var
os,
fs : longint;
i,
k : integer;
FSt,
WSt : string[255];
NSt : string[10];
begin
fs := n; {Initialize field count}
if (fs <= NumFields) then
BEGIN
os := 1;
WITH Fields^[fs] DO
BEGIN
CnvAscToStr(FieldName,FSt,11);
FSt := TrimR(FSt); {Remove trailing spaces}
move(CurRecord^[FieldAddress], WSt[1], FieldLen);
WSt[0] := char(FieldLen); {Set string length to field length}
FieldGetN := WSt;
LastFldTyp := FieldType;
LastFldDec := FieldDec;
LastFldLth := FieldLen;
LastFldNum := fs;
LastFldNam := FSt;
end;
end else
begin
str(n,NSt);
ShowError(603,NSt);
FieldGetN := '';
LastFldTyp := ' ';
LastFldDec := 0;
LastFldLth := 0;
LastFldNum := 0;
LastFldNam := '';
end;
end;
function GS_dBFld_Objt.FieldGet(st : string) : String;
var
fs : integer;
begin
if HuntFieldName(st,fs) then FieldGet := FieldGetN(fs)
else
begin
ShowError(602,st);
FieldGet := '';
LastFldTyp := ' ';
LastFldDec := 0;
LastFldLth := 0;
LastFldNum := 0;
LastFldNam := '';
end;
end;
Procedure GS_dBFld_Objt.FieldPutN(n : integer; st1 : string);
var
os,
fs : longint;
i,
k : integer;
FSt,
WSt : string[255];
NSt : string[10];
begin
fs := n; {Initialize field count}
if (fs <= NumFields) then
BEGIN
WITH Fields^[fs] DO
BEGIN
move(FieldName,FSt[1],11);
FSt[0] := #11;
FSt[0] := char(pred(pos(#0,FSt)));
FSt := TrimR(FSt); {Remove trailing spaces}
FillChar(CurRecord^[FieldAddress], FieldLen, ' ');
k := length(st1); {Get length of input string}
if k > FieldLen then k := FieldLen;
Move(st1[1], CurRecord^[FieldAddress], k);
LastFldTyp := FieldType;
LastFldDec := FieldDec;
LastFldLth := FieldLen;
LastFldNum := fs;
LastFldNam := FSt;
end;
end else
begin
str(n,NSt);
ShowError(605,NSt);
LastFldTyp := ' ';
LastFldDec := 0;
LastFldLth := 0;
LastFldNum := 0;
LastFldNam := '';
end;
end;
Procedure GS_dBFld_Objt.FieldPut(st1, st2 : string);
var
fs : integer;
begin
if HuntFieldName(st1,fs) then FieldPutN(fs,st2)
else
begin
ShowError(604,st1);
LastFldTyp := ' ';
LastFldDec := 0;
LastFldLth := 0;
LastFldNum := 0;
LastFldNam := '';
end;
end;
Function GS_dBFld_Objt.FieldUpdateScreen : boolean;
var
b,
i,
v,
x,
y,
ll : integer;
st,
s : string[12];
t : string;
activlin,
activfld : integer;
Procedure UpdatePage;
var
validcmd : boolean;
begin
validcmd := false;
if activfld < b then activfld := b;
if activfld >= b+v then activfld := pred(b+v);
activlin := succ(activfld - b);
if (activlin < 1) or (activlin > v) then activlin := 1;
repeat
t := FieldAccept(FieldsN^[activfld],'',13,activlin);
if (EditOn) and (not GS_KeyI_Esc) then FieldPutN(activfld,t);
if (not GS_KeyI_Fuc) and (GS_KeyI_Chr >= #32) then
GS_KeyI_Chr := Kbd_Ret;
case GS_KeyI_Chr of
Kbd_F9 : begin
gotoxy(3,ll);
GS_Wind_SetIvMode;
if DelFlag then write('Deleted')
else write('':8);
GS_Wind_SetNmMode;
end;
Kbd_PgUp : begin
if activfld = b then
begin
b := b-v;
if b < 1 then b := 1;
validcmd := true;
end
else activfld := b;
end;
Kbd_PgDn : begin
if activfld = pred(b+v) then
begin
b := b+v;
if b > NumFields-v then b := succ(NumFields-v);
if b < 1 then b := 1;
validcmd := true;
end
else activfld := pred(b+v);
end;
Kbd_UpAr : begin
dec(activfld);
if activfld < b then
begin
dec(b);
if b < 1 then b := 1;
validcmd := true;
end;
end;
Kbd_RtAr,
Kbd_Tab,
Kbd_Ret,
Kbd_DnAr : begin
inc(activfld);
if activfld > pred(b+v) then
begin
if activfld > NumFields then
activfld := NumFields
else
begin
inc(b);
if b > NumFields then
b := succ(NumFields-v);
validcmd := true;
end;
end;
end;
Kbd_Esc,
Kbd_F10 : validcmd := true;
end;
if activfld < b then activfld := b;
if activfld >= b+v then activfld := pred(b+v);
activlin := succ(activfld - b);
if (activlin < 1) or (activlin > v) then activlin := 1;
until validcmd;
end;
begin
ClrScr;
DeleteOnF9 := true;
RecChanged := false;
b := 1;
activfld := b;
ll := succ(hi(WindMax)-hi(WindMin));
v := pred(ll);
GS_Wind_SetIvMode;
gotoxy(2,ll);
write('':pred(lo(WindMax)-lo(WindMin)));
if EditOn then
begin
if RecNumber < 0 then {If Append, do the following}
begin
gotoxy(12,ll);
write('Append ');
write('EOF/',NumRecs);
end
else
begin {If Update do the following}
gotoxy(12,ll);
write('Update ');
write(RecNumber,'/',NumRecs);
end;
end else
begin {If Display then do this}
gotoxy(12,ll);
write('Display ');
write(RecNumber,'/',NumRecs);
end;
if DelFlag then
begin
gotoxy(3,ll);
write('Deleted');
end;
GS_Wind_SetNmMode;
if NumFields < v then v := NumFields;
x := 1;
y := 1;
Ch := ' ';
repeat
for i := b to pred(b+v) do
begin
s := FieldsN^[i];
FillChar(st[1],12,' ');
move(s[1],st[11-length(s)],length(s));
st[11] := ':';
st[0] := #12;
FieldDisplay(s,st,x,y);
case LastFldTyp of
'M' : begin
gotoxy(x+12,y);
write('---memo---');
if RecNumber < 0 then FieldPutN(LastFldNum,' ');
{If Append, make sure memo field is not}
{pointing to a memo block }
end;
end;
ClrEol;
inc(y);
end;
UpdatePage;
y := 1;
until (GS_KeyI_Chr in [Kbd_Esc,Kbd_F10]) or
((GS_KeyI_Chr = Kbd_PgUp) and (activfld = 1)) or
((GS_KeyI_Chr = Kbd_PgDn) and (activfld = NumFields));
DeleteOnF9 := false;
if GS_KeyI_Chr in [Kbd_F10, Kbd_PgUp, Kbd_PgDn] then
FieldUpdateScreen := true
else FieldUpdateScreen := false;
end;
Function GS_dBFld_Objt.FieldAppendScreen(empty : boolean) : boolean;
begin
if empty then Blank;
CurRecord^[0] := 32; {Ensure delete flag is off}
DelFlag := false;
RecNumber := -1;
FieldAppendScreen := FieldUpdateScreen;
end;
Function GS_dBFld_Objt.Formula(st : string) : string;
var
FldVal,
FldWrk : string;
FldPos : integer;
function HuntField(fldst : string) : String;
var
fs : integer;
ss : string;
FSt : string;
mtch : boolean;
begin
FSt := AllCaps(fldst); {Capitalize the workstring}
FSt := TrimR(FSt); {Remove trailing spaces}
fs := 1; {Initialize field count}
mtch := false; {Set match found to false}
while (not mtch) and (fs <= NumFields) DO
if FieldsN^[fs] = FSt then mtch := true else inc(fs);
if mtch then
begin
WITH Fields^[fs] DO
BEGIN
move(CurRecord^[FieldAddress], FSt[1], FieldLen);
FSt[0] := char(FieldLen); {Set string length to field length}
HuntField := FSt;
end;
end
else
begin
ss := TrimL(fldst);
if ss = '' then
begin
HuntField := '';
exit;
end;
if ss[1] = '"' then
begin
ss := TrimR(ss);
system.delete(ss,1,1);
if ss[length(ss)] = '"' then ss[0] := chr(pred(length(ss)));
HuntField := ss;
exit;
end;
ShowError(601,st+' ('+fldst+')');
HuntField := '';
end;
end;
begin
FldVal := ''; {Initialize the return string value}
FldWrk := st; {Move the input string to a work field}
while FldWrk <> '' do {Repeat while there is still something}
{in the work field.}
begin
FldPos := pos('+', FldWrk); {Search for a '+' delimiter}
if FldPos = 0 then FldPos := length(FldWrk)+1;
{If no '+' then simulate for this pass}
{by setting position to one beyond the}
{end of the target field string.}
FldVal := FldVal + HuntField(SubStr(FldWrk,1,FldPos-1));
{Go find the field using the substring}
{from the string's beginning to one }
{position before the '+' character.}
system.delete(FldWrk,1,FldPos); {Delete the string up through the '+'};
FldWrk := TrimL(FldWrk); {Remove leading spaces}
end;
Formula := FldVal; {Return value to calling routine}
end;
Procedure GS_dBFld_Objt.IndexTo(filname, formla : string);
var
i,
j,
fl : integer; {Local working variable}
ft : char;
{
┌──────────────────────────────────────────────────┐
│ This routine will accumulate the field length │
│ of all fields passes in the calling argument. │
│ This is needed to pass the formula length to │
│ create the index header. │
└──────────────────────────────────────────────────┘
}
procedure AccumField;
var
FldWrk : string;
FldLoc,
FldPos : integer;
begin
ft := '*'; {Set field type to new '*'}
fl := 0; {initialize field length}
FldWrk := TrimR(formla); {Remove trailing spaces from argument}
while FldWrk <> '' do {Repeat while there is still something}
{in the work field.}
begin
FldPos := pos('+', FldWrk); {Search for a '+' delimiter}
if FldPos = 0 then FldPos := length(FldWrk)+1;
{If no '+' then simulate for this pass}
{by setting position to one beyond the}
{end of the target field string.}
{Go find the field using the substring}
{from the string's beginning to one }
{position before the '+' character.}
if not HuntFieldName(SubStr(FldWrk,1,FldPos-1),FldLoc) then
begin
fl := 0;
exit;
end;
if ft = '*' then ft := LastFldTyp
else ft := 'C'; {Set type to C if more than one field}
{Else save this field's type }
fl := fl + Fields^[FldLoc].FieldLen;
{If a valid field, then add the field}
{length to the total field length value.}
system.delete(FldWrk,1,FldPos);
{Delete the string up through the '+'};
FldWrk := TrimL(FldWrk); {Remove leading spaces}
end;
end;
{
┌──────────────────────────────────────────────────┐
│ Main routine. This takes and analyzes the │
│ argument to build an index file. It does the │
│ following: │
│ 1. Reset current index files. │
│ 2. Get the total new formula field length. │
│ 3. Create an index file. │
│ 4. Build the index by reading all dbase │
│ records and updating the index file. │
└──────────────────────────────────────────────────┘
}
begin
i := 1;
while dbfNdxTbl[i] <> nil do
begin
dbfNdxTbl[i]^.Ndx_Close;
Dispose(dbfNdxTbl[i]);
dbfNdxTbl[i] := nil;
inc(i);
end;
dbfNdxActv := false; {Set index active flag to false}
if formla <> '' then
begin
AccumField; {Get field length of the formula}
if fl = 0 then
begin
ShowError(601,formla); {Display Error if formula is bad}
exit; {Exit if formula is no good}
end;
New(dbfNdxTbl[1]); {Create a new index object}
dbfNdxTbl[1]^.Ndx_Make(filname, formla, fl, ft);
{Go create an index}
Open;
GetRec(Top_Record); {Read all dBase file records}
while not File_EOF do
begin
dbfNdxTbl[1]^.KeyUpdate(Formula(formla),RecNumber,-1);
{Insert record in the index}
GetRec(Next_Record);
end;
{ dbfNdxTbl[1]^.KeyList('PRN');}
dbfNdxActv := true; {Set index active flag true if index }
GetRec(Top_Record); {Reset to top record}
end;
end;
constructor GS_dBFld_Objt.Init(FName : string);
begin
EditOn := true;
GS_dBase_DB.Init(FName);
Memo_Store.Init; {Initialize the edit object}
Memo_Store.Edit_Lgth := 50; {Set default memo line size to 50}
Wait_Cr := false; {Set EditString not to wait for CR}
DeleteOnF9 := false; {Turn off F9 for delete/undelete}
end;
function GS_dBFld_Objt.MemoGetLine(linenum : integer) : string;
begin
if linenum > Memo_Store.Total_Lines then
begin
MemoGetLine := '';
exit;
end;
if not Memo_Store.Find_Line(linenum) then
begin
MemoGetLine := '';
exit;
end;
MemoGetLine := Memo_Store.Work_line^.Valu_Line;
end;
Procedure GS_dBFld_Objt.MemoGet(rpt : string);
const
EOFMark : byte = $1A; {End of disk file code}
var
cnt, {Counter for memo storage location}
lCnt, {Counter for line length in characters}
mCnt : longint; {Counter for input buffer char position}
Result : word; {BlockRead number of bytes read}
done : boolean; {Flag set when end of memo field found}
i,j : integer; {Working variable}
Mem_Block : array [0..GS_dBase_MaxMemoRec] of byte;
{Input buffer}
BEGIN { Get Memo Field }
Val(rpt, Memo_Loc, i); {Save starting block number}
Memo_Bloks := 0; {Initialize blocks read}
Memo_Store.Clear_Editor; {Begin memo line count at zero}
{
┌─────────────────────────────────────┐
│ If no .DBT memo field for this │
│ record, then exit. │
└─────────────────────────────────────┘
}
if (Memo_Loc = 0) then exit;
Memo_Store.Work_Line := Memo_Store.Get_Line_Mem(Memo_Store.Edit_Lgth);
{Get the first edit line record}
Memo_Store.Active_Line := 1; {Set active line to first line}
done := false; {Reset done flag to false}
cnt := 0; {index into Memo_Store buffer}
lCnt := 0; {line length counter}
BEGIN
while (not done) do {loop until done (EOF mark)}
begin
GS_FileRead(mFile, Memo_Loc+Memo_Bloks, Mem_Block, 1, Result);
inc(Memo_Bloks);
mCnt := 0; {Counter into disk read buffer}
{
┌─────────────────────────────────────┐
│ Start reading and processing the │
│ sequential memo blocks until EOF │
│ mark is found. │
└─────────────────────────────────────┘
}
while (mCnt < GS_dBase_MaxMemoRec) and
(done = false) do
{
┌────────────────────────────────────────────┐
│ Repeat the following until you find an │
│ End-of-Memo condition. Read the next │
│ block each time mCnt reaches 512 bytes │
│ (GS_dBase_MaxMemoRec. Group the memo │
│ as a series of lines no greater than │
│ Memo_Width long. │
└────────────────────────────────────────────┘
}
begin
case Mem_Block[mCnt] of {Check for control characters}
$1A : begin
done := true; {End of Memo field}
if Memo_Store.Work_line^.Valu_Line = '' then
Memo_Store.Rel_Line_Mem(Memo_Store.Active_Line);
end;
$8D : begin {Soft Return (Wordstar and dBase editor)}
if (Memo_Store.Work_Line^.Valu_Line[lCnt] <> ' ') and
(Memo_Store.Work_Line^.Valu_Line[lCnt] <> '-') and
(lCnt > 0) then
begin
inc(lCnt); {Add to line length count}
Memo_Store.Work_Line^.Valu_Line[lcnt] := ' ';
{Insert a space in storage}
Memo_Store.Work_Line^.Valu_Line[0] := chr(lcnt);
end;
end;
$0A : begin {Linefeed}
end; {Ignore these characters}
$0D : begin {Hard Return}
With Memo_Store do
begin
Work_Line^.Return_Cod := $0D;
Work_Line := Get_Line_Mem(Edit_Lgth);
inc(Memo_Store.Active_Line);
lCnt := 0;
end;
end;
else {Here for other characters}
begin
inc(lCnt); {Add to line length count}
Memo_Store.Work_Line^.Valu_Line[lcnt] :=
chr(Mem_Block[mCnt]);
{Insert the character in storage}
Memo_Store.Work_Line^.Valu_Line[0] := chr(lcnt);
end;
end;
inc(mCnt); {Step to next input buffer location}
if lCnt > Memo_Store.Edit_Lgth then
{If lcnt longer than Memo_Width, you}
{must word wrap to Memo_Width length}
{or less}
begin
while (Memo_Store.Work_Line^.Valu_Line[lCnt] <> ' ') and
(Memo_Store.Work_Line^.Valu_Line[lCnt] <> '-') and
(lCnt > 0) do dec(lCnt);
{Repeat search for space or hyphen until}
{found or current line exhausted}
if (lCnt = 0) then
lcnt := length(Memo_Store.Work_Line^.Valu_Line) - 1;
{If no break point, truncate line}
with Memo_Store do
begin
Temp_Line := Work_Line^.Valu_Line;
system.delete(Temp_Line,1,lCnt);
if lCnt > Memo_Store.Edit_Lgth then
lCnt := Memo_Store.Edit_Lgth;
Work_Line^.Valu_Line[0] := chr(lcnt);
{Get string up to cursor to split line}
Work_Line := Get_Line_Mem(Edit_Lgth);
inc(Memo_Store.Active_Line);
Work_Line^.Return_Cod := $8D;
{Insert soft return character}
Work_Line^.Valu_Line := Temp_Line;
lCnt := length(Work_Line^.Valu_Line);
end;
end;
end;
END;
end;
END; { Get Memo Field }
Procedure GS_dBFld_Objt.MemoEdit;
begin
Memo_Store.Edit;
end;
Function GS_dBFld_Objt.MemoLines : integer;
begin
MemoLines := Memo_Store.Total_Lines;
end;
Procedure GS_dBFld_Objt.MemoWidth(l : integer);
begin
Memo_Store.Edit_Lgth := l;
end;
Function GS_dBFld_Objt.MemoPut : string;
const
EOFMark : byte = $1A; {End of disk file code}
var
bCnt, {Will hold bytes in memo field}
lCnt, {Counter for line length in characters}
mCnt,
tcnt : longint; {Counter for input buffer char position}
Result : word; {BlockWrite number of bytes written}
i : longint; {Working variable}
Mem_Block : array [0..GS_dBase_MaxMemoRec*2] of byte;
{Output buffer}
valu : string[10]; {work string to convert block number}
BEGIN { Put Memo Field }
bCnt := Memo_Store.Byte_Count; {Get count of bytes in memo field}
bCnt := bcnt div GS_dBase_MaxMemoRec;
{Get number of blocks required}
inc(bCnt); {Adjust from zero}
if bCnt > Memo_Bloks then
begin
GS_FileRead(mFile, 0, Mem_Block, 1, Result);
{read a block from the .DBT}
Move(Mem_Block[0],Memo_Loc,4);
{Get next block number to append}
end;
Memo_Bloks := bCnt; {Set blocks written count}
lCnt := 0; {line length counter}
mCnt := 0; {Counter into disk write buffer}
tCnt := Memo_Loc;
{
┌─────────────────────────────────────┐
│ Start reading and processing the │
│ sequential memo blocks until EOF │
│ mark is found. │
└─────────────────────────────────────┘
}
with Memo_Store do
begin
Work_Line := First_Line;
while (Work_Line <> nil) do
begin
move(Work_Line^.Valu_Line[1],Mem_Block[mCnt],
length(Work_Line^.Valu_Line));
mCnt := mCnt + length(Work_Line^.Valu_Line);
if Work_Line^.Next_Line <> nil then
begin
Mem_Block[mCnt] := Work_Line^.Return_Cod;
Mem_Block[mCnt+1] := $0A;
inc(mCnt,2);
end;
Work_Line := Work_Line^.Next_Line;
if (mCnt > GS_dBase_MaxMemoRec) then
begin
GS_FileWrite(mFile,tcnt,Mem_Block,1, Result);
{read a block from the .DBT}
inc(tcnt);
mCnt := mCnt mod GS_dBase_MaxMemoRec;
{Get excess buffer length used}
Move(Mem_Block[GS_dBase_MaxMemoRec],Mem_Block[0],mCnt);
{Move excess to beginning of buffer}
end;
end;
Mem_Block[mCnt] := EOFMark;
FillChar(Mem_Block[succ(mcnt)],GS_dBase_MaxMemoRec - mcnt,#0);
GS_FileWrite(mFile,tcnt,Mem_Block,1, Result);
{Write the last block to the .DBT}
i := GS_FileSize(mFile);
FillChar(Mem_Block,GS_dBase_MaxMemoRec,#0);
Move(i,Mem_Block[0],4);
GS_FileWrite(mFile,0,Mem_Block,1, Result);
{Write the block to the .DBT. It will}
{point to the next available block};
end;
Str(Memo_Loc:10,valu);
MemoPut := valu;
end;
end.
